home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / sys / gc_top.t < prev    next >
Encoding:
Text File  |  1990-06-15  |  7.8 KB  |  220 lines
  1. (herald gc_top
  2.   (env tsys (osys gc)
  3.             (osys gc_weak)       ;; for the GC-WEAK-???-LISTs
  4.             (osys frame)         ;; vframe stuff (temporary)
  5.             (osys table)))       ;; %TABLE-VECTOR must be integrated here
  6.  
  7. ;;; Copyright (c) 1985 Yale University
  8. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  9. ;;; This material was developed by the T Project at the Yale University Computer 
  10. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  11. ;;; and to use it for any purpose is granted, subject to the following restric-
  12. ;;; tions and understandings.
  13. ;;; 1. Any copy made of this software must include this copyright notice in full.
  14. ;;; 2. Users of this software agree to make their best efforts (a) to return
  15. ;;;    to the T Project at Yale any improvements or extensions that they make,
  16. ;;;    so that these may be included in future releases; and (b) to inform
  17. ;;;    the T Project of noteworthy uses of this software.
  18. ;;; 3. All materials developed as a consequence of the use of this software
  19. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  20. ;;;    of acknowledging credit in academic research.
  21. ;;; 4. Yale has made no warrantee or representation that the operation of
  22. ;;;    this software will be error-free, and Yale is under no obligation to
  23. ;;;    provide any services, by way of maintenance, update, or otherwise.
  24. ;;; 5. In conjunction with products arising from the use of this material,
  25. ;;;    there shall be no use of the name of the Yale University nor of any
  26. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  27. ;;;    without prior written consent from Yale in each case.
  28. ;;;
  29.  
  30. (lset *old-space* nil)
  31.  
  32. (lset *new-space* nil)
  33.  
  34. (define-simple-switch gc-noisily? boolean? '#f)
  35.  
  36. (lset *pre-gc-agenda*
  37.   (list pre-gc-fix-weak-sets
  38.         pre-gc-fix-weak-alists
  39.         pre-gc-fix-weak-tables
  40.         ))
  41.  
  42. (lset *post-gc-agenda*
  43.   (list post-gc-fix-weak-tables
  44.         post-gc-fix-weak-sets     ; fix any new ones
  45.         post-gc-fix-weak-alists
  46. ;        object-unhash-post-gc
  47.         ))
  48.  
  49. ;;;  GC sensitive things:
  50. ;;;                     PRE         POST
  51. ;;;    weaks             +           +
  52. ;;;    vcells            +           +
  53. ;;;    populations                   +      GC-UPDATE-THE-POPULATIONS
  54. ;;;    tables
  55. ;;;    pools             +                  POOL-PRE-GC-HOOK
  56. ;;;    streams                       +
  57. ;;;    free list         +                  PAIR-FREELIST-PRE-GC-HOOK
  58.  
  59. (lset *gc-problem?*         nil)
  60. (lset *gc-problem?-default* nil)
  61.  
  62. (define-operation (synch-area  area))
  63. (define-operation (reset-area  area))
  64. (define-operation (write-area  area))
  65.  
  66. (define-integrable (incr-area-frontier area length)
  67.   (set (area-frontier area) (fx+ (area-frontier area) length)))
  68.  
  69. (define-integrable (area-extent area)
  70.   (fx- (area-frontier area) (area-begin area)))
  71.  
  72. (define-structure-type area
  73.   id               
  74.   uid              ; for gc debugging (id,uid) must come first
  75.   size
  76.   base             ; base of area as an extend - see GC-FLIP
  77.   begin            ; base of area as a fixnum
  78.   frontier         ;++ changed from POINTER
  79.   limit            ; consing beyond this point causes a GC
  80.   (((reset-area self)
  81.     (if (eq? self (current-area))
  82.         (error "(reset-area ~s): area is current" self))
  83.     (set (area-base self) 0)
  84.     (zero-out-area self)
  85.     (set (area-frontier self) (area-begin self)))
  86.    ((synch-area self)
  87.     (if (neq? self (current-area))
  88.         (error "(synch-area ~s): area is not current" self))
  89.     (set (area-frontier self) (system-global slink/area-frontier)))
  90.    ((write-area self fd)
  91.     (vm-write-block fd (area-base self) (area-extent self)))
  92.    ((print-type-string self) "Area")
  93.    ((identification self) (area-id self))))
  94.  
  95. ;++flush uid ar 
  96.  
  97. (define (create-area id begin size uid)
  98.   (let ((area (make-area)))
  99.     (set (area-begin area) begin)
  100.     (set (area-frontier area) begin)
  101.     (set (area-limit area) (fx+ begin size))
  102.     (set (area-id area) id)
  103.     (set (area-uid area) uid)
  104.     (set (area-size area) size)
  105.     area))
  106.  
  107. (define-integrable (current-area)
  108.   (system-global slink/area))
  109.  
  110. (define (area-space-remaining)
  111.   (fx- (area-limit (current-area))
  112.        (system-global slink/area-frontier)))
  113.  
  114. (define (really-gc stack gc-frame)
  115.   (let ((z     *z?*)
  116.     (noise? (gc-noisily?)))
  117.     (set *z?* t)
  118.     (set *gc-problem?* *gc-problem?-default*)
  119.     (if noise? (gc-write-line ";Beginning GC"))
  120.     (walk1 (lambda (item) (item)) *pre-gc-agenda*)
  121.     (if noise? (gc-write-line ";*PRE-GC-AGENDA* done"))
  122.     (gc-flip)
  123.     (if noise? (gc-write-line ";GC-FLIP done"))
  124.     (set (system-global slink/pair-freelist) nil)
  125.     (set (system-global slink/snapper-freelist) nil)
  126.     (flush-code-vectors)
  127.     (if noise? (gc-write-line ";Starting to root"))
  128.     (gc-root stack gc-frame)
  129.     ;; The next line can't happen until after GC, when the area-object
  130.     ;; has been moved to new space.
  131.     (set (system-global slink/area) *new-space*)
  132.     (walk1 (lambda (item) (item)) *post-gc-agenda*)
  133.     (if noise? (gc-write-line ";*POST-GC-AGENDA* done"))
  134.     (set *z?* z)
  135.     (gc-done)
  136.     (if noise? (gc-write-line ";GC done"))
  137.     (if *gc-problem?* (breakpoint 'really-gc t-implementation-env))))
  138.  
  139. (define (gc-flip)
  140.   (exchange *old-space* *new-space*)
  141.   (synch-area *old-space*)
  142.   (set (system-global slink/old-space-begin) (area-begin *old-space*))
  143.   (set (system-global slink/old-space-frontier) (area-frontier *old-space*))
  144.   (set (system-global slink/area-frontier) (area-begin *new-space*))
  145.   (set (system-global slink/area-begin) (area-begin *new-space*))
  146.   (set (system-global slink/area-limit) (area-limit *new-space*))
  147.   (set (area-base *new-space*) (make-vector 0))
  148. ;  (advise-impure-area-access 'gc)
  149. ;  (advise-area-access *new-space* 'gc)
  150.   )
  151.  
  152. (define (gc-done)
  153. ;  (advise-impure-area-access 'random)
  154. ;  (advise-area-access *new-space* 'random)
  155.   (increment-gc-stamp)
  156.   (reset-area *old-space*)
  157. ;  (format t "; ~D objects copied~%" (fx+ *gc-click* *gc-object-count*))
  158.   (let ((free (fx- (system-global slink/area-limit)
  159.                    (system-global slink/area-frontier)))
  160.         (total (fx- (system-global slink/area-limit)
  161.                     (system-global slink/area-begin))))
  162.     (if (gc-noisily?) (gc-write-line (format nil ";Space Remaining: ~D left out of ~D (~D% free)"
  163.               free total 
  164.           (->integer (+ .5 (* 1.0 (/ (* 100.0 free) total)))))))))
  165.  
  166. (define (gc-root stack gc-frame)
  167.   (gc-scan-initial-impure-area)
  168.   (gc-scan-stack stack (system-global slink/stack))
  169.   (scan-gc-frame gc-frame)
  170. ;  (gc-write-line ";Root set traced")
  171.   (gc-scan-active-heap)
  172. ;  (gc-write-line ";Heap traced")
  173.   )
  174.  
  175. (define (gc-scan-stack frame bottom)
  176.   (cond ((fx> frame bottom))
  177.     (else
  178.      (cond ((frame? frame)
  179.         (let ((tem (extend-header frame)))
  180.           (if (in-old-space? tem)
  181.               (set (extend-header frame)
  182.                (gc-extend->pair (gc-extend->pair
  183.                  (gc-copy-template (gc-pair->extend
  184.                   (gc-pair->extend tem))))))))
  185.         (let ((size (frame-size frame)))
  186.           (trace-pointers frame size)
  187.           (gc-scan-stack (make-pointer frame size) bottom)))
  188.            (else
  189.         (gc-error-message "weird thing on stack" frame)
  190.         (gc-scan-stack (make-pointer frame 0) bottom))))))
  191.  
  192.  
  193. (define (scan-gc-frame frame)
  194.   (trace-pointers frame (fx+ *argument-registers* 5)))
  195.  
  196. (define (scan-interrupt-frame frame)
  197.   (trace-pointers frame (fx+ *argument-registers* 6)))
  198.  
  199. (define (trace-pointers obj ptrs)
  200.   (do ((i 0 (fx+ i 1)))
  201.       ((fx>= i ptrs) t)
  202.     (modify (extend-elt obj i) maybe-copy-object)))
  203.  
  204. ;;; True if an object is in old space.
  205. (define (flush-code-vectors)
  206.   (iterate loop ((l (weak-set-elements code-population)))
  207.     (cond ((null? l))
  208.       ((in-old-space? (car l))
  209.        (flush-code-from-icache (car l))
  210.        (loop (cdr l)))
  211.       (else (loop (cdr l))))))
  212.  
  213.  
  214. (define (gc-write-line string)
  215.   (fresh-line (error-output))
  216.   (write-string (error-output) string)
  217.   (newline (error-output)))
  218.  
  219. (set (gc-present?) '#t)
  220.